home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
thomas
/
thomas.lha
/
Thomas
/
Thomas-1.1
/
src
/
runtime-internal.scm
< prev
next >
Wrap
Text File
|
1992-09-20
|
5KB
|
123 lines
;* Copyright 1992 Digital Equipment Corporation
;* All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions. Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software. Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software. Correspondence should be provided to Digital at:
;*
;* Director, Cambridge Research Lab
;* Digital Equipment Corp
;* One Kendall Square, Bldg 700
;* Cambridge MA 02139
;*
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.
;*
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.
; $Id: runtime-internal.scm,v 1.9 1992/09/20 08:20:20 birkholz Exp $
;;;; This file contains the functions that are referenced only
;;;; directly by the output of the Dylan to Scheme compiler, rather
;;;; than user code written in Dylan.
;;;;
;;;; Many of the functions here are just renamings of ordinary Scheme
;;;; functions. The renaming is necessary to prevent name clashes
;;;; between Dylan and Scheme variables at run time.
(define (dylan::free-variable-ref value name)
(if (eq? value the-unassigned-value)
(dylan-call dylan:error "unbound variable" name)
value))
(define dylan::call/cc ; Used for BIND-EXIT
call-with-current-continuation)
(define (dylan::dotimes count result-fn fn)
;; Used for DOTIMES special form
(let loop ((n 0))
(if (>= n count)
(result-fn)
(begin
(fn n)
(loop (+ n 1))))))
(define (dylan::while test thunk)
;; Used for UNTIL and WHILE special forms
(let loop ()
(if (test)
(begin (thunk) (loop))
#F)))
(define (dylan::apply multiple-values? operator-thunk . operand-thunks)
;; Used for combinations.
;; Forces left-to-right evaluation, and adds an initial #F next
;; method argument.
(let loop ((rands '())
(rest operand-thunks))
(if (null? rest)
(apply (operator-thunk)
multiple-values?
NEXT-METHOD:NOT-GENERIC
(reverse rands))
(let ((next ((car rest))))
(loop (cons next rands) (cdr rest))))))
(define dylan::scheme-apply apply)
(define dylan::dynamic-wind ; Used for UNWIND-PROTECT
dynamic-wind)
(define (dylan::type-check value class) ; Used for BIND
; (let ((type-of-object (get-type value)))
; (if (not (subclass? type-of-object class))
; (dylan-call dylan:error
; "BINDing-time restriction violation" class value)))
;; Should signal a <type-error>!
(dylan-call dylan:check-type value class))
(define dylan::list list) ; BIND
(define dylan::cons cons) ; BIND
(define dylan::car car) ; BIND
(define dylan::vector vector) ; BIND
(define dylan::vector-ref vector-ref) ; BIND
(define dylan::not not) ; DEFINE-GENERIC-FUNCTION, UNLESS
(define dylan::eq? eq?) ; DEFINE-GENERIC-FUNCTION
(define dylan::class? class?) ; DEFINE-CLASS
(define dylan::make-param-list ; METHOD
make-param-list)
(define dylan::add-method add-method) ; DEFINE-METHOD
(define dylan::null? null?) ; COND
(define (dylan::for-each fn . collections)
(for-each
(lambda (collection)
(if (not (subclass? (get-type collection) <collection>))
(dylan-call dylan:error "for-each -- not a collection" collection)))
collections)
(collections-iterate fn
(lambda (result)
(and result (lambda () (car result))))
#F
collections))